Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/allowo1g/domtree.frm

Visual Basic Form | 1999-08-27 | 17.6 KB | 442 lines

VERSION 5.00
Object = "{EAB22AC0-30C1-11CF-A7EB-0000C05BAE0B}#1.1#0"; "SHDOCVW.DLL"
Begin VB.Form frmDOMTree
   BackColor       =   &H00FFFFFF&
   Caption         =   "DOM Tree"
   ClientHeight    =   4395
   ClientLeft      =   60
   ClientTop       =   630
   ClientWidth     =   5880
   LinkTopic       =   "Form1"
   MDIChild        =   -1  'True
   ScaleHeight     =   4395
   ScaleWidth      =   5880
   WindowState     =   2  'Maximized
   Begin SHDocVwCtl.WebBrowser wbr
      Height          =   2235
      Left            =   720
      TabIndex        =   0
      Top             =   840
      Width           =   4515
      ExtentX         =   7964
      ExtentY         =   3942
      ViewMode        =   0
      Offline         =   0
      Silent          =   0
      RegisterAsBrowser=   0
      RegisterAsDropTarget=   1
      AutoArrange     =   0   'False
      NoClientEdge    =   0   'False
      AlignLeft       =   0   'False
      ViewID          =   "{0057D0E0-3573-11CF-AE69-08002B2E1262}"
      Location        =   ""
   End
   Begin VB.Menu mnuFileMenu
      Caption         =   "&File"
      Index           =   0
      Begin VB.Menu mnuFile
         Caption         =   "&HTML"
         Index           =   0
      End
      Begin VB.Menu mnuFile
         Caption         =   "-"
         Index           =   1
      End
      Begin VB.Menu mnuFile
         Caption         =   "&Close"
         Index           =   2
      End
   End
Attribute VB_Name = "frmDOMTree"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
' DOMTree.frm   July 1999  contact [e-mail]
' Demonstrates DOM programming from Vb6 including
'   recursive traversal of an HTML document structure   (see RecurseDOMTree)
'   extracting stylesheet information from a document   (see DisplayStyleSheets)
'   constructing an expand/collapse UL object and inserting it into a document
'   cloning a structure (see CreatePropsClone, CreateInfoSpan)
'   intercepting click events from WebBrowser document  (see mProps, mExpand)
'   behavior (DOMTree.htc) attached to DIV (MainDIV) via CSS class (DOMTree.css)
' Requires Project/References entry for
'   Microsoft HTML Object Library (MSHTML.tlb)
'====================================================================================
' Enumerations
Public Enum DOMInfoType ' determines which display is built - see DisplayDOMInfo
    domiTree    ' Document Tree
    domiStyle   ' Style Specs
End Enum
' Module-level Object variables
Private mvarMDIParent As MDIForm    ' useful to access parent form - see StatusText
Private mDOMDoc As MSHTML.HTMLDocument  ' document to be analysed - see DisplayDOMInfo
Private mWbrDoc As MSHTML.HTMLDocument  ' document in WebBrowser (HTML_TEMPLATE)
Private mWbrDocWin As MSHTML.HTMLWindow2    ' window containing WebBrowser document
Attribute mWbrDocWin.VB_VarHelpID = -1
Private mULRoot As MSHTML.HTMLUListElement      ' top-level UL added to WebBrowser document
Private mCloneSPAN As MSHTML.HTMLSpanElement    ' see CreatePropsClone
' Objects in WebBrowser document HTML_TEMPLATE
Private mProgressNodes As MSHTML.IHTMLDOMTextNode   ' progress display
Private WithEvents mProps As MSHTML.HTMLTableCell   ' toggles properties display
Attribute mProps.VB_VarHelpID = -1
Private WithEvents mExpand As MSHTML.HTMLTableCell  ' expands/collapses tree display
Attribute mExpand.VB_VarHelpID = -1
' Miscellaneous module-level variables
Private mDefaultPath As String      ' assigned in Form_Initialize
Private mDOMInfoType As DOMInfoType ' indicates which display is built
Private mDOMInfoCaption As Variant  ' array of caption strings
Private mNodeCount As Long          ' compared with PROGRESS_INTERVAL
' Module-level Constants
Private Const PROGRESS_INTERVAL As Long = 20    ' see AddLInode_Exit
Private Const HTML_TEMPLATE = "DOMTree.htm"     ' template for building display
Private Const CL_INFOSPAN = "infoSPAN"
Private Const CL_PARENT = "clParent"
Private Const CL_CHILD = "clChild"
Private Const WORKING = " Working ..."
Private Const READY = " Ready"
' Relevant nodeType constants
Private Const ELEMENT_NODE = 1
Private Const TEXT_NODE = 3
' Browser navigation constants
Private Const navNoHistory = 2
' File Menu Constants
Private Const FILE_HTML = 0
Private Const FILE_CLOSE = 2
Public Property Set MDIParent(vData As MDIForm) ' optional
   Set mvarMDIParent = vData
End Property
Private Property Let StatusText(ByVal vData As String)
    On Error Resume Next
    If Not (mvarMDIParent Is Nothing) Then  ' property spec is optional
        mvarMDIParent.StatusText = vData
    End If
End Property
Public Sub DisplayDOMInfo( _
            HTMLDoc As MSHTML.HTMLDocument, _
            InfoType As DOMInfoType)

    Set mDOMDoc = HTMLDoc   ' retain as module-level variable
    mDOMInfoType = InfoType ' retain as module-level variable
    Me.Caption = mDOMInfoCaption(mDOMInfoType)
' Processing is triggered when HTML_TEMPLATE is loaded (see wbr_DocumentComplete)
    wbr.Navigate URL:=mDefaultPath & HTML_TEMPLATE, Flags:=navNoHistory
End Sub
Private Sub Form_Initialize()
    mDefaultPath = App.Path & "\"
    mDOMInfoCaption = Array("Document Tree", "Style Specs")
    mDOMInfoType = domiTree  ' default DOMDocInfo property
End Sub
Private Sub Form_Load()
    StatusText = WORKING
    wbr.Navigate "about:<BODY style='overflow:auto'></BODY>", Flags:=navNoHistory
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Me.Visible = False  ' An attempt to speed up closing the form because
    DoEvents            '   displosing of the document may take a while.
End Sub
Private Sub Form_Resize()
    On Error Resume Next
    wbr.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight
End Sub
Private Sub mnuFile_Click(Index As Integer)
    On Error Resume Next
    Select Case Index
        Case FILE_HTML

            With New frmDOMHTML
                .Show
                .DisplayHTML HTMLDoc:=wbr.Document
            End With

        Case FILE_CLOSE

            Unload Me

    End Select
End Sub
Private Sub wbr_DocumentComplete(ByVal pDisp As Object, URL As Variant)
    If pDisp Is wbr.object Then
        If InStr(1, URL, HTML_TEMPLATE, vbTextCompare) Then
            Set mWbrDoc = wbr.Document  ' typecast for early binding
            With mWbrDoc
                Set mWbrDocWin = .parentWindow
                Set mProgressNodes = .getElementById("idRow").firstChild
                .getElementById("idHdr").firstChild.nodeValue = mDOMInfoCaption(mDOMInfoType)
            End With
            DoEvents
            Select Case mDOMInfoType
                Case domiTree
                    RecurseDOMTree StartFromNode:=mDOMDoc.getElementsByTagName("HTML")(0)
                Case domiStyle
                    DisplayStyleSheets HTMLDoc:=mDOMDoc
            End Select
            StatusText = READY
        End If
    End If
End Sub
Private Function mProps_onclick() As Boolean    ' Event generated in HTML_TEMPLATE
    Dim blnShow As Boolean
    StatusText = WORKING
    mWbrDocWin.Event.cancelBubble = True
    blnShow = InStr(1, mProps.firstChild.nodeValue, "Show", vbTextCompare)
    PropsToggle ShowAll:=blnShow
    mProps.firstChild.nodeValue = IIf(blnShow, "Hide", "Show") & " properties"
    StatusText = READY
End Function
Private Function mExpand_onclick() As Boolean   ' Event generated in HTML_TEMPLATE
    Dim blnExpand As Boolean
    StatusText = WORKING
    mWbrDocWin.Event.cancelBubble = True
    blnExpand = InStr(1, mExpand.firstChild.nodeValue, "Expand", vbTextCompare)
    ExpandToggle ExpandAll:=blnExpand
    mExpand.firstChild.nodeValue = IIf(blnExpand, "Collapse", "Expand") & " all"
    StatusText = READY
End Function
Private Sub RecurseDOMTree(StartFromNode As MSHTML.IHTMLDOMNode)
    On Error GoTo RecurseDOMTree_Error
' Initialise a node for cloning (see notes in CreatePropsClone)
    Set mCloneSPAN = CreatePropsClone(HTMLDoc:=mWbrDoc)
' Create RootNode (fully constructed before added to HTML_TEMPLATE in WebBrowser)
    Set mULRoot = mWbrDoc.createElement("UL")
' Initiate Recursion
    If StartFromNode.hasChildNodes Then
        ForEachChild FromNode:=StartFromNode, ULParent:=mULRoot
    End If
' Insert the UL Object into the document (in place of 'Working...')
    With mWbrDoc.getElementById("MainDIV")
        .replaceChild newChild:=mULRoot, oldChild:=.firstChild
    End With
' Make clickable options available and monitor using 'WithEvents' variable
    With mWbrDoc
        Set mProps = .getElementById("idProps")     ' see mProps_onclick
        Set mExpand = .getElementById("idExpand")   ' see mExpand_onclick
    End With
    mProps.runtimeStyle.visibility = "visible"
    mExpand.runtimeStyle.visibility = "visible"
RecurseDOMTree_Exit:
    Exit Sub
RecurseDOMTree_Error:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, "RecurseDOMTree"
    Resume RecurseDOMTree_Exit
End Sub
Private Sub ForEachChild( _
            FromNode As MSHTML.IHTMLDOMNode, _
            ULParent As MSHTML.HTMLUListElement) ' RECURSIVE

    On Error GoTo ForEachChild_Error
    Dim oLI As MSHTML.HTMLLIElement
    Dim oULchild As MSHTML.HTMLUListElement
    Dim oNode As MSHTML.IHTMLDOMNode
    Set oNode = FromNode.firstChild
    Do Until oNode Is Nothing
        Set oLI = AddLInode(oNode, ULParent)
        If oNode.hasChildNodes Then
            oLI.className = CL_PARENT   ' and create new UL for these children
            Set oULchild = ULParent.appendChild(mWbrDoc.createElement("UL"))
            oULchild.className = CL_CHILD
            ForEachChild FromNode:=oNode, ULParent:=oULchild ' RECURSIVE CALL
        End If
        Set oNode = oNode.nextSibling
   Loop
ForEachChild_Exit:
    Exit Sub
ForEachChild_Error:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, "ForEachChild"
    Resume ForEachChild_Exit
End Sub
Private Function AddLInode( _
            N As MSHTML.IHTMLDOMNode, _
            ULParent As MSHTML.IHTMLDOMNode) As MSHTML.HTMLLIElement

    On Error GoTo AddLInode_Error
    Dim oLI As MSHTML.HTMLLIElement
    Dim IsText As Boolean
    Dim strCaption As String
    With N
        IsText = .nodeType = TEXT_NODE
        If IsText Then
            strCaption = .nodeValue
        Else
            strCaption = .nodeName
        End If
    End With
    Set oLI = ULParent.appendChild(mWbrDoc.createElement("LI"))
    With oLI
        .appendChild mWbrDoc.createTextNode(strCaption)
        If Not IsText Then
            .appendChild CreateInfoSpan(N)
        End If
    End With
    Set AddLInode = oLI
AddLInode_Exit:
    mNodeCount = mNodeCount + 1
    If mNodeCount Mod PROGRESS_INTERVAL = 0 Then    ' refresh progress display
        mProgressNodes.Data = mNodeCount
        DoEvents
    End If
    Exit Function
AddLInode_Error:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, "AddLInode"
    Resume AddLInode_Exit
End Function
Private Function CreateInfoSpan(DOMNode As MSHTML.IHTMLDOMNode) As MSHTML.HTMLSpanElement
    On Error GoTo CreateInfoSpan_Error
    Dim oSPAN As MSHTML.HTMLSpanElement
    Dim oID As MSHTML.HTMLSpanElement
    Dim oMSHTMLType As MSHTML.HTMLSpanElement
    Dim strID As String
    Dim strClassName As String
' Clone a new info object (see CreatePropsClone)
    Set oSPAN = mCloneSPAN.cloneNode(True)  ' see CreatePropsClone - only 2 childNodes
    Set oID = oSPAN.firstChild              ' <== use index if more than 2 SPANs are
    Set oMSHTMLType = oSPAN.lastChild       ' <== included in the cloned object
' ID - defined on document, or allocated by system as 'uniqueID'
    With DOMNode
        If Len(.id) Then
            strID = .id
            strClassName = "idSPAN"
        Else
            strID = .uniqueID
            strClassName = "uniqueIdSPAN"
        End If
    End With
    With oID
        .className = strClassName
        .firstChild.nodeValue = strID
    End With
' MSHTML Library Type
    oMSHTMLType.firstChild.nodeValue = TypeName(DOMNode)
CreateInfoSpan_Exit:
    Set CreateInfoSpan = oSPAN
    Exit Function
CreateInfoSpan_Error:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, "CreateInfoSpan"
    Resume CreateInfoSpan_Exit
End Function
Private Function PropsToggle(ShowAll As Boolean) As Long
    On Error GoTo PropsToggle_Error
    Dim Result As Long ' default function result is 0 (= False)
    Dim oSPANcollection As MSHTML.IHTMLElementCollection
    Dim strVisibility As String
    Dim IX As Long, IXmax As Long
    strVisibility = IIf(ShowAll, "visible", "hidden")
    Set oSPANcollection = mULRoot.getElementsByTagName("SPAN")
    IXmax = oSPANcollection.length - 1
    For IX = 0 To IXmax
        With oSPANcollection(IX) ' an HTMLSpanElement object
            If .className = CL_INFOSPAN Then
                .runtimeStyle.visibility = strVisibility
            End If
        End With
    Next IX
    Result = IXmax + 1  ' returns number of elements toggled
PropsToggle_Exit:
    PropsToggle = Result
    Exit Function
PropsToggle_Error:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, "PropsToggle"
    Resume PropsToggle_Exit
End Function
Private Function ExpandToggle(ExpandAll As Boolean) As Long
    On Error GoTo ExpandToggle_Error
    Dim Result As Long ' default function result is 0 (= False)
    Dim oULcollection As MSHTML.IHTMLElementCollection
    Dim strDisplay As String
    Dim IX As Long, IXmax As Long
    strDisplay = IIf(ExpandAll, "block", "")
    Set oULcollection = mULRoot.getElementsByTagName("UL")
    IXmax = oULcollection.length - 1
    For IX = 0 To IXmax
        With oULcollection(IX) ' an HTMLUListElement object
            If .className = CL_CHILD Then
                .runtimeStyle.display = strDisplay
            End If
        End With
    Next IX
    Result = IXmax + 1  ' returns number of elements toggled
ExpandToggle_Exit:
    ExpandToggle = Result
    Exit Function
ExpandToggle_Error:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, "ExpandToggle"
    Resume ExpandToggle_Exit
End Function
Private Function CreatePropsClone(HTMLDoc As MSHTML.HTMLDocument) As MSHTML.HTMLSpanElement
' The object created here is cloned to display node properties
'   SPAN (class=infoSPAN)
'       SPAN (class=idSPAN)
'           #text
'       SPAN (class=mshtmlSPAN)
'           #text
    On Error GoTo CreatePropsClone_Error
    Dim Result As MSHTML.HTMLSpanElement    ' default function result is Nothing
    Dim oParent As MSHTML.HTMLSpanElement
    Dim oChild As MSHTML.HTMLSpanElement
    With HTMLDoc
        Set oParent = .createElement("SPAN")
        Set oChild = .createElement("SPAN")
        oChild.appendChild .createTextNode(" ")
    End With
    With oParent
        .className = CL_INFOSPAN
        .Style.visibility = "hidden"
        .appendChild(oChild).className = "idSPAN"
        .appendChild(oChild.cloneNode(True)).className = "mshtmlSPAN"
    End With
    Set Result = oParent
CreatePropsClone_Exit:
    Set CreatePropsClone = Result
    Exit Function
CreatePropsClone_Error:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, "CreatePropsClone"
    Resume CreatePropsClone_Exit
End Function
Private Sub DisplayStyleSheets(HTMLDoc As MSHTML.HTMLDocument)

    On Error GoTo DisplayStyleSheets_Error
    Dim oRules As MSHTML.HTMLStyleSheetRulesCollection
    Dim varStyles() As String
    Dim varStyle As Variant
    Dim IXStyleSheet As Long
    Dim IX As Long
    Dim oLIparent As MSHTML.HTMLLIElement
    Dim strSelectorText As String
' Create RootNode (fully constructed before added to document)
    Set mULRoot = mWbrDoc.createElement("UL")
    For IXStyleSheet = 0 To HTMLDoc.styleSheets.length - 1
        Set oRules = HTMLDoc.styleSheets(IXStyleSheet).rules
        For IX = 0 To oRules.length - 1
            With oRules(IX)
                varStyles = Split(.Style.cssText, ";")
                strSelectorText = .selectorText
                With mULRoot.appendChild(mWbrDoc.createElement("LI"))
                    .className = CL_PARENT
                    .appendChild mWbrDoc.createTextNode(strSelectorText)
                End With
                With mULRoot.appendChild(mWbrDoc.createElement("UL"))
                    .className = CL_CHILD
                    For Each varStyle In varStyles
                        With .appendChild(mWbrDoc.createElement("LI"))
                            .appendChild mWbrDoc.createTextNode(varStyle)
                        End With
                    Next
                End With
            End With
        Next IX
    Next IXStyleSheet
' Insert the UL Object into the document (in place of 'Working...')
    With mWbrDoc.getElementById("MainDIV")
        .replaceChild newChild:=mULRoot, oldChild:=.firstChild
    End With
' Make clickable option available and monitor for click
    Set mExpand = mWbrDoc.getElementById("idExpand")
    mExpand.runtimeStyle.visibility = "visible"
DisplayStyleSheets_Exit:
    Exit Sub
DisplayStyleSheets_Error:
    MsgBox Err.Number & " - " & Err.Description, vbExclamation, "DisplayStyleSheets"
    Resume DisplayStyleSheets_Exit
End Sub